;;;; engine.lisp

(in-package "engine")


;;; "engine" goes here. Hacks and glory await!

(defparameter *debug* nil "To turn on debugging information set this value to T")

(defmacro defun-with-logs (name  args &rest body)
  (let (
	(result-name (gensym))
	(arg-names  
	 (loop for arg in args
	    when (and (symbolp arg) (not (find #\& (symbol-name arg))))
	    collect arg)))
;    arg-names))
    `(defun ,name ,args 
       (format t "~&Entering method ~a" (symbol-name (quote ,name)))
       (format t "~&Params :~{~&~{~t~a = ~a~}~}"
	       (mapcar (lambda (a b) (append (list a) (list b))) (quote ,arg-names) 
		       (list ,@arg-names)))
       (let (( ,result-name 
	      (progn ,@body)))
	 (format t "~&Exiting method ~a; Result = ~a" (symbol-name (quote ,name)) ,result-name)
	 ,result-name))))

(defun-with-logs debug-on () (setf *debug* T))

(defun-with-logs debug-off () (setf *debug* nil))

(defun-with-logs init-maps ()
  (defparameter *unit-stats* (utilities:alist-to-hash (utilities:read-object "unit-stats.obj")) "This is a hash-map to store unit stats")
    (defparameter *weapon-stats* (utilities:alist-to-hash (utilities:read-object "weapon-stats.obj")) "this is a hash-map to store weapon stats"))

;(defun-with-logs format-log (format-message &rest par) (if *debug* (eval `(format t ,format-message ,@par))))

;(defun-with-logs print-log (print-object) (if *debug* (prin1 print-object) print-object))
 
(defun-with-logs roll-d6 ()
  (let ((result (+ (random 6) 1)))
;	(print result)
	result))

(defun-with-logs resolve-to-hit-p (bs)
  (format t "~&Resolve roll to hit with BS - ~a" bs)
  (if (> bs 5)
      (or (resolve-shot-p 5) (resolve-shot-p (- bs 5)))
  (let ((roll (roll-d6)) (to-roll (- 7 bs)))
    (roll-result-p roll to-roll))))

(defun-with-logs to-wound (strength toughness)
  (+ 4 (- toughness strength)))

(defun-with-logs resolve-wound-p (strength toughness)
  (format t "~&Resolve roll to wound of strength ~a versus toughness ~a" strength toughness)
  (let ((roll (roll-d6)) (to-roll (to-wound strength toughness)))
    (roll-result-p roll to-roll)))

(defun-with-logs roll-result-p (roll to-roll)
  (format t "~&Roll resolution: to roll = ~a, roll = ~a" to-roll roll)
  (if (> roll 1)
      (>= roll to-roll)))

(defun-with-logs resolve-armor-save-p (sv ap)
nn  (format t "~&Resolve armor save of ~a versus shot of AP ~a" sv ap)
  (if (< sv ap)
  (roll-result-p (roll-d6) sv)))

(defun-with-logs resolve-invul-save-p (sv)
  (roll-result-p (roll-d6) sv))

(defun-with-logs cover-save-p (sv)
  (roll-result-p (roll-d6) sv))

(defun-with-logs update-list-value (list key value)
  (let ((result (copy-list list)))
  (setf (cdr (assoc key result)) value)
  result))

(defun-with-logs unit-stat (unit stat)
  (utilities:get-hash-alist *unit-stats* (cdr (assoc :type unit)) stat))

(defun-with-logs weapon-stat (unit stat)
  (utilities:get-hash-alist *weapon-stats* (cdr (assoc :weapon unit)) stat))

(defun-with-logs weapon-record (range strength ap type)
  (list (cons :range range) (cons :s strength) (cons :ap ap) (cons :type type)))

;method is deprecated. use regiment-shot instead
;(defun-with-logs shoot (shooter target)
;  (format t "~&~a shoots at ~a" (cdr (assoc :type shooter)) (cdr (assoc :type target)))
;  (and (line-of-sight-p)
;       (resolve-distance-p)
;       (resolve-to-hit-p (unit-stat shooter :bs))
;       (resolve-wound-p (weapon-stat shooter :s) (unit-stat target :t))
;       (not (resolve-armor-save-p (unit-stat target :sv) (weapon-stat shooter :ap)))))
 
(defun-with-logs visible-p (shooter target-unit battlefield)
  (format t "~&Resolving vision")
  (if  (print (loop for target in target-unit
	   when (not (loop for cover in battlefield
			when (loop for side in (cdr (assoc :sides cover))
				do (format t "~& target is ~a ~& cover is ~a ~& side is a ~a" target cover side)
				when (print (intersects-p 
					     (list (cdr (assoc :x shooter)) (cdr (assoc :y shooter)) 
						   (cdr (assoc :x target)) (cdr (assoc :y target)))
					     side))
				return T)
			return T))
	   return T))
	T
	(format t "~&No targets are visible")))
	
       

(defun-with-logs resolve-distance-p (shooter target-unit)
  (progn 
    (format t "~&Weapon range is ~a" (inch (weapon-stat shooter :range)))
    (format t "~&Resolving distance from x:~a y:~a" (assoc :x shooter) (assoc :y shooter))
    (loop for target in target-unit
       when 
	 (and 
	  (assoc :x shooter)
	  (assoc :y shooter)
	  (assoc :x target) 
	  (assoc :y target) 
	  (let* ((x (- (cdr (assoc :x shooter)) (cdr (assoc :x target))))
		 (y (- (cdr (assoc :y shooter)) (cdr (assoc :y target)))))
	    (format t "~&~t~t~tTo ~a ~a . Distance in units: " (assoc :x target) (assoc :y target))
	    (< (princ (sqrt (+ (* x x) (* y y)))) (inch (weapon-stat shooter :range)))))
       return T)))

  

(defun-with-logs map-shots (landed-shots target-unit)
  (if landed-shots
      (multiple-value-bind 
	    (shots-per-target extra-shots)
	  (truncate (length landed-shots) (length target-unit))
	(loop for target in target-unit
	   for i1 from 0
	   collect (append 
		    (loop for i2 from 1 to shots-per-target 
		       collect (nth (- (+ (* i1 shots-per-target) i2) 1) landed-shots))
		    (if (> extra-shots 0)
			(progn (decf extra-shots)
			       (list (nth (+ (* shots-per-target (length target-unit)) i1) landed-shots)))))))))


; for each shooter resolve visibility
; for each shooter resolve distance limitation
; for each shooter resolve to hit
; for each successfull hit resolve to wound
; allocate wounds
; for each wound resolve saves
; calculate casualties
; return survivors

(defun-with-logs regiment-shot (shooter-unit target-unit battlefield)
  (let* ((target-unit-copy (copy-tree target-unit))
	   (unit-toughness 
	  (round  
	   (loop for target in target-unit-copy sum (unit-stat target :t)) 
	   (length target-unit-copy)))
	 (successful-shots 
	    (loop for shooter in shooter-unit
	       when (and
		     (visible-p shooter target-unit-copy battlefield)
		     (resolve-distance-p shooter target-unit)
		     (resolve-to-hit-p (unit-stat shooter :bs))
		     (resolve-wound-p (weapon-stat shooter :s) unit-toughness))
	       collect (cdr (assoc :weapon shooter))))
	 (shots-map (map-shots successful-shots target-unit-copy)))
    (format t "~&Shots map to target models ~a " shots-map)
    (if shots-map
	(loop for target in target-unit-copy
	   for salvo in shots-map 
	   do (loop for shot in salvo
		 when (not (resolve-armor-save-p (unit-stat target :sv) (weapon-stat (list (cons :weapon shot)) :ap)))
		 do (decf (cdr (assoc :wounds target))))
	   when (> (cdr (assoc :wounds target)) 0)
	   collect target)
	target-unit)))
		   
;transform inches into position units
;one position unit equals 0.1 mm
(defun-with-logs inch (inches)
  (* 254 inches))

;transforms degree angle into rads
(defun-with-logs rad (angle)
  (* PI (/ angle 180)))


; set position of the first model
; calculate tan of the troops line
; set troops along the line

(defun-with-logs position-unit (x y view-angle unit &optional (distance 2))
  (let* (
	 (formation-angle (+ view-angle (rad 90)))
	 (left-wing (* -1 (round (- (length unit) 1) 2)))
	 (x-delta (round (* (inch distance) (sin formation-angle))))
	 (y-delta (round (* (inch distance) (cos formation-angle))))
	 (unit-copy (copy-tree unit)))
    (loop for model in unit-copy
       for i from left-wing
       collect 
	 (let ((new-x (round (+  x (* i x-delta))))
	       (new-y (round (+  y (* i y-delta)))))
	   (if (null (assoc :x model))
	       (setf model (append model (list (cons :x new-x))))
	       (setf (cdr (assoc :x model)) new-x))
	   (if (null (assoc :y model))
	       (setf model (append model (list (cons :y new-y))))
	       (setf (cdr (assoc :y model)) new-y))
	   model))))


;intersection method
;

(defun-with-logs intersects-p (line-1 line-2)
  (let* (
	 (x11 (nth 0 line-1))
	 (y11 (nth 1 line-1))
	 (x12 (nth 2 line-1))
	 (y12 (nth 3 line-2))
	 (x21 (nth 0 line-2))
	 (y21 (nth 1 line-2))
	 (x22 (nth 2 line-2))
	 (y22 (nth 3 line-2))
	 (k1 (- (* (- y12 y11) (- x21 x22)) (* (- y21 y22) (- x12 x11))))
	 (k2 (- (* (- y12 y11) (- x21 x11)) (* (- y21 y11) (- x12 x11))))
	 (k3 (- (* (- y21 y11) (- x21 x22)) (* (- y21 y22) (- x21 x11)))))
    (and 
     (/= k1 0)
     (<= 0 (/ k2 k1))
     (<= (/ k2 k1) 1)
     (<= 0 (/ k3 k1))
     (<= (/ k3 k1) 1))))

